home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 7: Sunsite / Linux Cubed Series 7 - Sunsite Vol 1.iso / system / shells / scsh-0.4 / scsh-0 / scsh-0.4.2 / rts / condition.scm < prev    next >
Text File  |  1995-10-13  |  2KB  |  77 lines
  1. ; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
  2. ; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees.  See file COPYING.
  3.  
  4.  
  5. ; This is file condition.scm.
  6.  
  7. ;;;; Condition hierarchy
  8.  
  9. ; General design copied from gnu emacs.
  10.  
  11. (define *condition-types* '())
  12.  
  13. (define (condition-supertypes type)
  14.   (assq type *condition-types*))
  15.  
  16. (define (define-condition-type type supertypes)
  17.   (set! *condition-types*
  18.     (cons (cons type (apply append
  19.                 (map (lambda (sup)
  20.                        (or (condition-supertypes sup)
  21.                        (error "unrecognized condition type"
  22.                           sup)))
  23.                      supertypes)))
  24.           *condition-types*)))
  25.  
  26. (define (condition-predicate name)
  27.   (lambda (c)
  28.     (and (pair? c)
  29.      (let ((probe (condition-supertypes (car c))))
  30.        (if probe
  31.            (if (memq name probe) #t #f)
  32.            #f)))))
  33.  
  34. (define (condition? x)
  35.   (and (pair? x)
  36.        (list? x)
  37.        (condition-supertypes (car x))))
  38. (define condition-type car)
  39. (define condition-stuff cdr)
  40.  
  41.  
  42. ; Errors
  43.  
  44. (define-condition-type 'error '())
  45. (define error? (condition-predicate 'error))
  46.  
  47. (define-condition-type 'call-error '(error))
  48. (define call-error? (condition-predicate 'call-error))
  49.  
  50. (define-condition-type 'read-error '(error))
  51. (define read-error? (condition-predicate 'read-error))
  52.  
  53. ; Exceptions
  54.  
  55. (define-condition-type 'exception '(error))
  56. (define exception? (condition-predicate 'exception))
  57. (define exception-opcode cadr)
  58. (define exception-arguments cddr)
  59.  
  60. (define (make-exception opcode args)
  61.   (make-condition 'exception (cons opcode args)))
  62.  
  63.  
  64. ; Warnings
  65.  
  66. (define-condition-type 'warning '())
  67. (define warning? (condition-predicate 'warning))
  68.  
  69. (define-condition-type 'syntax-error '(warning))
  70. (define syntax-error? (condition-predicate 'syntax-error))
  71.  
  72.  
  73. ; Interrupts
  74.  
  75. (define-condition-type 'interrupt '())
  76. (define interrupt? (condition-predicate 'interrupt))
  77.